#Librerias
library(tidyverse)
library(tidymodels)
library(GGally)
library(ggplot2)
library(MASS)
library(robustbase)
library(dplyr)
library(corrplot)
library(caret)
library(viridis)
library(gridExtra)
library(kableExtra)
El fútbol es el deporte más popular, el que tiene un mercado más grande y en el cual el valor de las transferencias de los jugadores es el más alto. En ese sentido, nos proponemos analizar las transferencias y cotizaciones de los jugadores de las cinco ligas mas importantes de Europa:
Por este motivo, y haciendo uso de los conocimientos aportados por la materia, optamos por profundizar en el desarrollo de métodos de regresión robustos para hacer análisis predictivos, haciendo foco en la explicabilidad del modelo para predecir las transferencias de los jugadores.
El objetivo del presente trabajo consiste en la utilización distintos métodos robustos para predecir la variable objetivo: el precio de transferencia de los jugadores.
En el método lineal clásico se utiliza el método de cuadrados mínimos para encontrar los parámetros \(\beta\).
La función de pérdida que se quiere minimizar es la suma del cuadrado de los residuos.
\[ g(a, b) = \sum_{i=1}^n \left( Y_i - \left( a + b X_i \right) \right)^2 \quad \text{(1)} \]
En los modelos lineales robustos queremos cambiar la función de perdida tal que:
\[ g(a, b) = \sum_{i=1}^n \rho \left( \frac{Y_i - \left( a + b X_i \right)}{s_n} \right) \quad \text{(2)} \]
Definición de la función ρ
Sea ρ: R → R una función que cumple las siguientes propiedades:
Esta función ρ es acotada, creciente y simétrica alrededor del cero, características que la hacen especialmente útil para la estimación robusta.
Una posibilidad es ajustar una recta usando un procedimiento de ajuste robusto, por ejemplo un MM-estimador de regresión, propuesto por Yohai [1987]. En R, esto está programado dentro de la rutina lmrob en el paquete robustbase de R. La estimación se hace en tres etapas, se propone un estimador inicial de los parámetros, a partir de él se estima a sn y manualmente se obtienen los estimadores de los parámetros a partir de ellos, minimizando la función objetivo
Existen varias funciones \(\rho\) que serán evaluadas en el presente trabajo. Por defecto, robustbase utiliza la bicuadrada (bisquare), pero también se pueden implementar lqq, welsh, optimal, etc.
Robustbase utiliza el algoritmo Iteratively Reweighted Least Squares (IRWLS) para estimar los parámetros \(\beta\). El proceso consiste en la siguientes etapas:
Inicializar el proceso utilizando un estimación inicial de a y b utilizando el método de cuadrados mínimos.
Derivar la función (2) respecto a los parámetros a y b: \[ \frac{\partial g}{\partial a} = \sum_{i=1}^{n} \psi \left(\frac{Y_i - (a + bX_i)}{s_n} \right) \cdot \frac{-1}{s_n} \quad \text{(3)} \] \[ \frac{\partial g}{\partial b} = \sum_{i=1}^{n} \psi \left(\frac{Y_i - (a + bX_i)}{s_n} \right) \cdot \frac{-X_i}{s_n} \quad \text{(4)} \]
donde
\[ \frac{d \rho(x)}{dx} = \psi(x) \quad \text{(5)} \]
\[ w_i = \frac{\psi \left(\frac{Y_i - (a + bX_i)}{s} \right)}{\frac{Y_i - (a + bX_i)}{s}} \quad \text{(6)} \]
Se multiplica a cada observación por su respectivo peso.
Se vuelven a estimar los parámetros a y b con una regresión ponderada.
Se repiten los pasos hasta no observar mas mejoras o hasta un máximo de iteraciones.
A continuación se muestran las funciones \(\rho\) más comunes y como se comportan los pesos de las mismas.
# set margins for plots
options(SweaveHooks=list(fig=function() par(mar=c(3,3,1.4,0.7),
mgp=c(1.5, 0.5, 0))))
## x axis for plots:
x. <- seq(-5, 10, length.out = 1501)
source(system.file("xtraR/plot-psiFun.R", package = "robustbase", mustWork=TRUE))
getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "biweight", par = 4.685)
getOption("SweaveHooks")[["fig"]]()
plot(huberPsi, x., ylim=c(-1.4, 5), leg.loc="topright", main=FALSE)
getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "Welsh", par = 2.11)
getOption("SweaveHooks")[["fig"]]()
## see also hampelPsi
p.psiFun(x., "Hampel", par = ## Default, but rounded:
round(c(1.5, 3.5, 8) * 0.9016085, 1))
getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "LQQ", par = c(-.5,1.5,.95,NA))
getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "optimal", par = 1.06, leg.loc="bottomright")
Donde \(k\), \(a\), \(b\), \(c\), \(c_1\), \(c_2\) y \(c_3\) son constantes que determinan los puntos de quiebre y la forma de cada función.
Existen muchas otras propuestas de estimadores robustos para regresión, por ejemplo LMS (least median of squares), LTS (least trimmed squares), τ−estimadores de regresión, y casi todas están implementadas en R.
El set de datos consiste en dos bases, ambas obtenidas de Kaggle.
La base de datos con los precios de los jugadores se obtuvo de la web Transfermarkt. Cuenta con 32405 registros, y dos de sus variables son los precios actuales de los jugadores y el precio mas alta alcanzado. Además cuenta con la información del club y liga actual de cada jugador.
Las otra base de datos cuenta con las métricas durante la temporada 2023/2024 de los jugadores de las 5 ligas mas importantes del fútbol europeo. Algunas de sus variables son Edad, goles anotados, asistencias, posición dentro del campo de juego, nacionalidad, entre otras.
Ambas bases de datos se unieron por el nombre y apellido del jugador, y el club actual. Adicionalmente, se agregó la variable Continente al dataset final, la cual informa el continente natal de cada jugador.
El dataset se divide en Entrenamiento y Prueba, de manera estratificada según el precio. Se utiliza el siguiente boxplot para generar una nueva categoría que categorice según el precio del jugador.
Luego utilizaremos esta nueva variable para realizar la división del dataset de manera estratificada.
El objetivo es que quedan estratificados los jugadores mas caros u outliers, por eso no se realiza una división por debajo de Q2.
# Carga de datset
# setwd("/Users/jorgefernandez/Documents/Cienciadedatos/EEA2024/TP02")
setwd("/Users/rmarques/UBA/EEA/german-eea-2024/TP02")
df <- as.data.frame(read.csv("dataset.csv"))
df <- as.data.frame(df)
df <- na.omit(df)
colnames(df)[colnames(df) == "market_value_in_eur"] <- "precio"
# Agregar nueva variable que tenga en cuenta los precios de los jugadores y poder hacer un split
# test-train estratificado
caja_precios <- boxplot(df$precio)
df$precio_cat <- NA
for (i in 1:length(df$precio)) {
if (df$precio[i] >= 100000000) {
df$precio_cat[i] <- "muy_alto"}
if (df$precio[i] < 100000000 && df$precio[i] >= caja_precios$stats[5]) {
df$precio_cat[i] <- "alto"}
if (df$precio[i] < caja_precios$stats[5] && df$precio[i] >= caja_precios$stats[4]) {
df$precio_cat[i] <- "medio"}
if (df$precio[i] < caja_precios$stats[4] && df$precio[i] >= caja_precios$stats[3]) {
df$precio_cat[i] <- "bajo"}
if (df$precio[i] < caja_precios$stats[3]){
df$precio_cat[i] <- "muy_bajo"}
}
# Suponiendo que `df$clase` es la variable categórica
set.seed(28749658) # Fijar semilla para reproducibilidad
# Crear índices estratificados basados en la variable `clase`
train_indices <- createDataPartition(df$precio_cat, p = 0.7, list = FALSE) # 70% entrenamiento
# Dividir los datos
train_data <- df[train_indices, ]
test_data <- df[-train_indices, ]
table(train_data$precio_cat)
##
## alto bajo medio muy_alto muy_bajo
## 132 298 171 10 546
table(test_data$precio_cat)
##
## alto bajo medio muy_alto muy_bajo
## 56 127 73 4 234
colnames(df)[colnames(df) == "market_value_in_eur"] <- "precio"
df$continente <- factor(df$continente, levels = c("europa", "america", "africa", "asia_oceania"))
grafico1 <- ggplot(df, aes(x=continente, fill = continente)) +
geom_bar() +
scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
labs(y = "Cantidad",
x = "Continente",
title = "Cantidad de jugadores por continente") +
theme_minimal() +
theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1),
legend.position = "none")
df$Comp <- factor(df$Comp, levels = c("es La Liga", "it Serie A", "fr Ligue 1", "de Bundesliga",
"eng Premier League"))
grafico2 <- ggplot(df, aes(x=Comp, fill = Comp)) +
geom_bar() +
scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
labs(y = "Cantidad", x = "Liga", title = "Cantidad de jugadores por liga") +
theme_minimal() +
theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1),
legend.position = "none")
posiciones <- table(df$position)
posiciones <- names(sort(posiciones))
df$position <- factor(df$position, levels = posiciones)
grafico3 <- ggplot(df, aes(x=position, fill = position)) +
geom_bar() +
scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
labs(y = "Count", x = "Posiciones", title = "Cantidad de jugadores por posicion") +
theme_minimal() +
theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1,),
legend.position = "none")
grafico4 <- ggplot(df, aes(x=foot, fill = foot)) +
geom_bar() +
scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
labs(y = "Count", x = "Pie hábil", title = "Cantidad de jugadores por pie habil") +
theme_minimal() +
theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1,),
legend.position = "none")
grid.arrange(grafico1, grafico2, grafico3, grafico4,nrow = 2)
Como era de esperarse, predominan los jugadores europeos. Los americanos y africanos están casi en igual medida, siendo un poco mayor los americanos. Asia y Oceanía en conjunto aportan solo una mínima cantidad.
Todas las ligas están igual de representadas en el dataset, con lo cual el análisis del precio de jugadores según la liga será de interés.
La mayor cantidad de jugadores son Defensores, y en menor medida los Mediocampistas y Delanteros, pero todas estas posiciones están uniformemente distribuidas. Como es de esperarse, los Arquero es la posición de menor representación.
Como era de esperarse, mas de la mitad de los jugadores son derechos. Sin embargo, comparado con la proporción de personas diestras en el mundo (85%), la cantidad de jugadores zurdos es bastante mayor a estar proporción.
df %>%
dplyr::select(Age, Gls, Ast, precio) %>%
mutate(liga = df$current_club_domestic_competition_id) %>%
ggpairs(., mapping = aes(colour = liga),
upper = list(continuous = wrap("cor", size = 3, hjust=0.5)), progress=FALSE) +
scale_color_viridis_d(option = "D") +
scale_fill_viridis_d(option = "D") +
theme(axis.text.x = element_text(angle = 90, hjust = 1), legend.position = "bottom") +
theme_bw() +
labs(title='Correlograma variables continuas')
Se observa una correlación positiva alta a moderada (Corr: 0.502). Esto sugiere que los jugadores que marcan más goles tienden a tener un valor de mercado más alto. La relación parece ser consistente a través de las diferentes ligas. Siendo menos pronunciada en las ligas española y francesa donde parecería que la cantida de goles anotados tiene menos importancia que en el resto de las ligas, y mas pronunciada en la liga inglesa donde parecería que la cantida de goles anotados tiene mas importancia que el resto de las ligas.
Existe una correlación positiva moderada (Corr: 0.465). Indica que los jugadores que dan más asistencias también tienden a tener un mayor valor en el mercado. La correlación es algo menor que con los goles, sugiriendo que el mercado valora más la capacidad goleadora. Se observa la misma tendencia que para la cantidad de goles, es menos pronunciada en las ligas española y francesa donde parecería que la cantida de asistencias tiene menos importancia que en el resto de las ligas, y mas pronunciada en la liga inglesa donde parecería que la cantida de asistencias tiene mas importancia que el resto de las ligas.
Se observa una correlación negativa baja pero clara (Corr: -0.176). Sugiere que el valor de mercado tiende a disminuir con la edad del jugador. Esto tiene sentido desde una perspectiva de inversión, ya que los jugadores más jóvenes tienen mayor potencial de desarrollo y años de carrera por delante. En este caso, la liga español tiene una pendiente mas negativa lo que podría evidenciar que los jugadores jovenes son mas valorados que el resto de las ligas, en cambio en la liga francesa se observa una pendiente mas suave con lo cual podría indicar que se valora mas la experiencia que el resto de las ligas.
Los diagramas de caja (boxplots) muestran diferencias en la distribución de precios entre ligas. Las ligas española y británica presentan valores más altos en general. Esto se alinea con el poder económico de estas ligas y específicamente de clubes como Real Madrid y Manchester City. La distribución de precios es notablemente asimétrica, con algunos valores muy altos que podrían considerarse outliers.
Existe una correlación positiva moderada entre goles y asistencias (Corr: 0.586). Esto sugiere que los jugadores más efectivos tienden a destacar tanto en goles como en asistencias. La edad muestra correlaciones muy débiles con goles y asistencias.
Los 10 jugadores mas caros
mas_caros_nombre <- df %>%
slice_max(order_by = precio, n=10) %>%
pull(name)
mas_caros_equipo <- df %>%
slice_max(order_by = precio, n=10) %>%
pull(Squad)
mas_caros_precio <- df %>%
slice_max(order_by = precio, n=10) %>%
pull(precio)
mas_caro <- data.frame(Nombre = mas_caros_nombre,
Equipo = mas_caros_equipo,
Precio = mas_caros_precio)
kable(mas_caro)
| Nombre | Equipo | Precio |
|---|---|---|
| erling haaland | manchester city | 2.0e+08 |
| vinicius junior | real madrid | 2.0e+08 |
| jude bellingham | real madrid | 1.8e+08 |
| lamine yamal | barcelona | 1.5e+08 |
| phil foden | manchester city | 1.5e+08 |
| bukayo saka | arsenal | 1.4e+08 |
| federico valverde | real madrid | 1.3e+08 |
| florian wirtz | leverkusen | 1.3e+08 |
| rodri | manchester city | 1.3e+08 |
| declan rice | arsenal | 1.2e+08 |
Los 10 jugadores mas baratos
mas_baratos_nombre <- df %>%
slice_min(order_by = precio, n=10) %>%
pull(name)
mas_baratos_equipo <- df %>%
slice_min(order_by = precio, n=10) %>%
pull(Squad)
mas_baratos_precio <- df %>%
slice_min(order_by = precio, n=10) %>%
pull(precio)
mas_barato <- data.frame(Nombre = mas_baratos_nombre,
Equipo = mas_baratos_equipo,
Precio = mas_baratos_precio)
kable(mas_barato)
| Nombre | Equipo | Precio |
|---|---|---|
| aurelien pelon | lorient | 50000 |
| daouda traore | nice | 50000 |
| sofiane sidi ali | marseille | 50000 |
| steven baseya | strasbourg | 50000 |
| yassin tallal | getafe | 50000 |
| simone aresti | cagliari | 75000 |
| adel mahamoud | nantes | 100000 |
| antonio mirante | milan | 100000 |
| daniele sommariva | genoa | 100000 |
| dominic sadi | bournemouth | 100000 |
| francesco rossi | atalanta | 100000 |
| ichem ferrah | lille | 100000 |
| ivan cuellar | mallorca | 100000 |
| joel imasuen | werder bremen | 100000 |
Precio = Goles
modelo_clasico_goles = lm(data = train_data, formula = precio ~ Gls)
summary(modelo_clasico_goles)
##
## Call:
## lm(formula = precio ~ Gls, data = train_data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -58318585 -5505828 -3505828 2261548 112681415
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5238452 519499 10.08 <2e-16 ***
## Gls 3267375 147163 22.20 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 15400000 on 1155 degrees of freedom
## Multiple R-squared: 0.2991, Adjusted R-squared: 0.2985
## F-statistic: 492.9 on 1 and 1155 DF, p-value: < 2.2e-16
ggplot(df, aes(x= Gls, y=precio))+
geom_point() +
theme_bw() +
geom_smooth(method = "lm", formula = y ~ x, color="forestgreen", se = FALSE)
datos_augmentados <- augment(modelo_clasico_goles)
g1 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
geom_point() +
geom_hline(yintercept = 0) +
geom_smooth(se = FALSE) +
labs(title = "Residuos vs valores predichos") +
theme_bw()
g2 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
stat_qq() +
geom_abline() +
labs(title = "Normal QQ plot") +
theme_bw()
g3 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Scale-location plot")
g4 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
geom_vline(size = 2, colour = "white", xintercept = 0) +
geom_hline(size = 2, colour = "white", yintercept = 0) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Residual vs leverage")
grid.arrange(g1, g2, g3, g4, nrow=2)
pred_modelo_clasico_goles <- augment(modelo_clasico_goles, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)
## RMSE: 15388866
cat("MAE: ", mae(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)
## MAE: 9179813
pred_modelo_clasico_goles <- augment(modelo_clasico_goles, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)
## RMSE: 17503869
cat("MAE: ", mae(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)
## MAE: 9732598
Este modelo, aunque estadísticamente significativo, tiene limitaciones importantes para predecir el precio de los jugadores. La violación de los supuestos básicos y el bajo poder explicativo sugieren que se necesita un modelo más complejo que incorpore variables adicionales y posiblemente transformaciones de las variables existentes.
Precio = \(Edad\) + \(Edad^2\)
modelo_clasico_edad = modelo_clasico_edad2 = lm(data = train_data, formula = precio ~ Age + I(Age^2))
summary(modelo_clasico_edad)
##
## Call:
## lm(formula = precio ~ Age + I(Age^2), data = train_data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -13491197 -9734927 -5198104 2200547 186201791
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -45547305 13549572 -3.362 0.000801 ***
## Age 5113615 1054307 4.850 1.40e-06 ***
## I(Age^2) -110147 20094 -5.482 5.18e-08 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 17940000 on 1154 degrees of freedom
## Multiple R-squared: 0.05018, Adjusted R-squared: 0.04853
## F-statistic: 30.48 on 2 and 1154 DF, p-value: 1.255e-13
ggplot(df, aes(x= Age, y=precio))+
geom_point() +
theme_bw() +
geom_smooth(method = "lm", formula = y ~ x + I(x^2), color="forestgreen", se = FALSE)
cat("A partir de los", round(5113615/(2*110147),0), "años, el precio de los jugadores comienza a disminuir")
## A partir de los 23 años, el precio de los jugadores comienza a disminuir
datos_augmentados <- augment(modelo_clasico_edad)
g1 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
geom_point() +
geom_hline(yintercept = 0) +
geom_smooth(se = FALSE) +
labs(title = "Residuos vs valores predichos") +
theme_bw()
g2 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
stat_qq() +
geom_abline() +
labs(title = "Normal QQ plot") +
theme_bw()
g3 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Scale-location plot")
g4 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
geom_vline(size = 2, colour = "white", xintercept = 0) +
geom_hline(size = 2, colour = "white", yintercept = 0) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Residual vs leverage")
grid.arrange(g1, g2, g3, g4, nrow=2)
pred_modelo_clasico_edad <- augment(modelo_clasico_edad, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)
## RMSE: 17914627
cat("MAE: ", mae(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)
## MAE: 10519126
pred_modelo_clasico_edad <- augment(modelo_clasico_edad, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)
## RMSE: 18482683
cat("MAE: ", mae(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)
## MAE: 10655848
Este modelo confirma que existe una relación no lineal entre la edad y el precio de los jugadores, con un punto máximo alrededor de los 23 años. Sin embargo, su bajo poder explicativo sugiere que la edad debe combinarse con otras variables para obtener predicciones más precisas.
\(Precio\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)
modelo_clasico_multiple_1 = lm(data = train_data,
formula = precio ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id)
summary(modelo_clasico_multiple_1)
##
## Call:
## lm(formula = precio ~ Gls + Age + I(Age^2) + Ast + continente +
## current_club_domestic_competition_id, data = train_data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -37702078 -5979937 -1352304 4179402 117568853
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -8999579 10503367 -0.857 0.391719
## Gls 2189855 160682 13.629 < 2e-16
## Age 1607300 804050 1.999 0.045844
## I(Age^2) -44966 15312 -2.937 0.003384
## Ast 2152607 244624 8.800 < 2e-16
## continenteamerica 4494113 1848911 2.431 0.015223
## continenteasia_oceania 2283362 3956794 0.577 0.564003
## continenteeuropa 2748364 1459721 1.883 0.059981
## current_club_domestic_competition_idFR1 -4436917 1268565 -3.498 0.000487
## current_club_domestic_competition_idGB1 11060116 1286087 8.600 < 2e-16
## current_club_domestic_competition_idIT1 -2429060 1229943 -1.975 0.048515
## current_club_domestic_competition_idL1 -4011806 1265818 -3.169 0.001568
##
## (Intercept)
## Gls ***
## Age *
## I(Age^2) **
## Ast ***
## continenteamerica *
## continenteasia_oceania
## continenteeuropa .
## current_club_domestic_competition_idFR1 ***
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1 *
## current_club_domestic_competition_idL1 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 13350000 on 1145 degrees of freedom
## Multiple R-squared: 0.4783, Adjusted R-squared: 0.4733
## F-statistic: 95.43 on 11 and 1145 DF, p-value: < 2.2e-16
datos_augmentados <- augment(modelo_clasico_multiple_1)
g5 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
geom_point() +
geom_hline(yintercept = 0) +
geom_smooth(se = FALSE) +
labs(title = "Residuos vs valores predichos") +
theme_bw()
g6 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
stat_qq() +
geom_abline() +
labs(title = "Normal QQ plot") +
theme_bw()
g7 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Scale-location plot")
g8 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
geom_vline(size = 2, colour = "white", xintercept = 0) +
geom_hline(size = 2, colour = "white", yintercept = 0) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Residual vs leverage")
grid.arrange(g5, g6, g7, g8, nrow=2)
pred_modelo_clasico_multiple_1 <- augment(modelo_clasico_multiple_1, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)
## RMSE: 13276913
cat("MAE: ", mae(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)
## MAE: 8093280
pred_modelo_clasico_multiple_1 <- augment(modelo_clasico_multiple_1, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)
## RMSE: 15450180
cat("MAE: ", mae(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)
## MAE: 8469906
Este modelo representa una mejora sustancial sobre los modelos simples anteriores, capturando efectos más complejos y reduciendo los errores de predicción. Sin embargo, aún hay espacio para mejoras, especialmente en el tratamiento de valores extremos y la posible incorporación de más variables relevantes.
\(log(Precio)\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)
Al utilizar una transformación logarítmica, la interpretación del modelo es diferente, ya que se introduce una relación de semielasticidad entre las variables. La variación de la variable a predecir es en términos porcentuales según aumenta en una unidad la variable predictora numérica o según la variable de referencia categórica.
Por lo tanto:
\[ c = (\exp(b) - 1) \times 100 \quad \text{(13)} \]
Donde
\[ y = a + b \times x \quad \text{(14)} \]
En este caso, si \(x\) es una variable numérica entonces \(y\) varía \(c\)% por cada aumento de \(x\) en una unidad. Si en cambio \(x\) es una variable categórica, \(y\) varía \(c\)% con respecto a la variable categórica de referencia.
modelo_clasico_multiple = lm(data = train_data,
formula = log(precio) ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id)
summary(modelo_clasico_multiple)
##
## Call:
## lm(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + continente +
## current_club_domestic_competition_id, data = train_data)
##
## Residuals:
## Min 1Q Median 3Q Max
## -4.0055 -0.6931 0.0515 0.7146 3.5105
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.573579 0.844203 6.602 6.19e-11
## Gls 0.116194 0.012915 8.997 < 2e-16
## Age 0.787591 0.064625 12.187 < 2e-16
## I(Age^2) -0.016285 0.001231 -13.232 < 2e-16
## Ast 0.172888 0.019662 8.793 < 2e-16
## continenteamerica 0.404139 0.148605 2.720 0.00664
## continenteasia_oceania 0.007232 0.318025 0.023 0.98186
## continenteeuropa 0.041694 0.117324 0.355 0.72237
## current_club_domestic_competition_idFR1 -0.296188 0.101960 -2.905 0.00374
## current_club_domestic_competition_idGB1 0.817675 0.103369 7.910 6.02e-15
## current_club_domestic_competition_idIT1 -0.027229 0.098856 -0.275 0.78303
## current_club_domestic_competition_idL1 -0.285435 0.101740 -2.806 0.00511
##
## (Intercept) ***
## Gls ***
## Age ***
## I(Age^2) ***
## Ast ***
## continenteamerica **
## continenteasia_oceania
## continenteeuropa
## current_club_domestic_competition_idFR1 **
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1
## current_club_domestic_competition_idL1 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.073 on 1145 degrees of freedom
## Multiple R-squared: 0.467, Adjusted R-squared: 0.4619
## F-statistic: 91.21 on 11 and 1145 DF, p-value: < 2.2e-16
Los siguientes histogramas muestran como mejora la ditribución de los precios aplicando la distribución lograrítmica logrando una aproximación a los normalidad y homocedasticidad de los datos a predecir.
hist1 <- ggplot(df, aes(x=precio))+
geom_histogram() +
labs(title = "Histograma del Precio") +
theme_bw()
hist2 <- ggplot(df, aes(x=log(precio)))+
geom_histogram() +
labs(title = "Histograma del log(Precio)") +
theme_bw()
grid.arrange( hist1, hist2, nrow=1)
En este caso, el valor de \(R^2\) ajustado del modelo es con respecto a la variable transformada, por lo tanto tenemos que predecir todos los datos utilizados en el modelo y trasformarlos exponencialmente para obtener el valor real del salario por hora esperado.
Finalmente, se calcula el valor de \(R^2\) ajustado “manualmente”.
pred_modelo_clasico_multiple <- augment(modelo_clasico_multiple, newdata = train_data)
pred_modelo_clasico_multiple$exp_fitted <- exp(pred_modelo_clasico_multiple$.fitted)
metricas1 = metrics(data = pred_modelo_clasico_multiple,
truth = precio, estimate = exp_fitted) %>%
mutate(.estimate = round(.estimate, 4))
#rcuadrado <- metricas1$.estimate[2]
#cat("R-cuadrado = ", rcuadrado)
#metricas1
# Calcular el R² ajustado manualmente
n <- nrow(pred_modelo_clasico_multiple) # Número de observaciones
p <- length(coef(modelo_clasico_multiple)) - 1 # Número de predictores (restamos 1 por el intercepto)
r2 <- metricas1 %>% filter(.metric == "rsq") %>% pull(.estimate)
r2_ajustado <- 1 - ((1 - r2) * (n - 1) / (n - p - 1))
# Mostrar el R² ajustado
cat("R^2 ajustado = ", r2_ajustado)
## R^2 ajustado = 0.2908521
datos_augmentados <- augment(modelo_clasico_multiple)
g9 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
geom_point() +
geom_hline(yintercept = 0) +
geom_smooth(se = FALSE) +
labs(title = "Residuos vs valores predichos") +
theme_bw()
g10 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
stat_qq() +
geom_abline() +
labs(title = "Normal QQ plot") +
theme_bw()
g11 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Scale-location plot")
g12 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
geom_vline(size = 2, colour = "white", xintercept = 0) +
geom_hline(size = 2, colour = "white", yintercept = 0) +
geom_point() +
geom_smooth(se = FALSE) +
theme_bw() +
labs(title = "Residual vs leverage")
grid.arrange(g9, g10, g11, g12, nrow=2)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)
## RMSE: 28500598
cat("MAE: ", mae(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)
## MAE: 8057781
pred_modelo_clasico_multiple <- augment(modelo_clasico_multiple, newdata = test_data)
pred_modelo_clasico_multiple$exp_fitted <- exp(pred_modelo_clasico_multiple$.fitted)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)
## RMSE: 17508456
cat("MAE: ", mae(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)
## MAE: 7357616
La transformación logarítmica del precio mejora las propiedades estadísticas del modelo y facilita la interpretación de los efectos. Este modelo parece más adecuado para predecir el precio de los jugadores, especialmente cuando se considera la interpretabilidad y la estabilidad de las predicciones.
Precio = Goles
Se utiliza el modelo base de Robustbase, donde la fución de pérdida utilizada es la bicuadrada y utiliza el estimador MM.
modelo_lmrob_goles <- lmrob(formula = precio ~ Gls, data=train_data)
pred_modelo_lmrob_goles <- data.frame(
Gls = train_data$Gls,
precio_pred = predict(modelo_lmrob_goles, newdata = train_data)
)
summary(modelo_lmrob_goles)
##
## Call:
## lmrob(formula = precio ~ Gls, data = train_data)
## \--> method = "MM"
## Residuals:
## Min 1Q Median 3Q Max
## -11398849 -2040823 -40823 7178107 172914731
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 3040823 233384 13.03 < 2e-16 ***
## Gls 890535 123689 7.20 1.08e-12 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Robust residual standard error: 3632000
## Multiple R-squared: 0.2183, Adjusted R-squared: 0.2177
## Convergence in 23 IRWLS iterations
##
## Robustness weights:
## 158 observations c(3,19,23,52,55,58,67,76,80,83,89,92,105,112,130,132,141,143,144,156,161,163,164,167,172,173,175,178,190,200,204,212,216,218,226,232,248,253,256,262,265,271,283,287,288,289,290,292,301,309,310,316,319,321,322,327,333,338,339,341,354,366,367,368,372,384,385,388,390,407,433,461,463,474,476,482,484,488,489,500,501,510,526,537,543,563,564,565,575,578,584,586,593,597,602,608,630,634,640,646,662,666,674,691,695,696,705,713,736,753,754,760,764,774,793,799,800,801,806,811,813,823,833,853,857,867,870,871,875,901,913,917,918,929,934,953,954,962,963,965,968,973,982,1024,1036,1052,1053,1063,1070,1091,1096,1100,1123,1124,1132,1134,1138,1154)
## are outliers with |weight| <= 4.7e-05 ( < 8.6e-05);
## 44 weights are ~= 1. The remaining 955 ones are summarized as
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.002176 0.877400 0.959300 0.855000 0.983700 0.999000
## Algorithmic parameters:
## tuning.chi bb tuning.psi refine.tol
## 1.548e+00 5.000e-01 4.685e+00 1.000e-07
## rel.tol scale.tol solve.tol zero.tol
## 1.000e-07 1.000e-10 1.000e-07 1.000e-10
## eps.outlier eps.x warn.limit.reject warn.limit.meanrw
## 8.643e-05 4.911e-11 5.000e-01 5.000e-01
## nResample max.it best.r.s k.fast.s k.max
## 500 50 2 1 200
## maxit.scale trace.lev mts compute.rd fast.s.large.n
## 200 0 1000 0 2000
## psi subsampling cov
## "bisquare" "nonsingular" ".vcov.avar1"
## compute.outlier.stats
## "SM"
## seed : int(0)
El siguiente gráfico muestra la linea de regresión del modelo lineal clásico (violeta) frente a la regresión del modelo robusto (amarillo).
Se puede apreciar muy claramente como el modelo robusto tiene una pendiente mas baja ajustando en menor medida a los jugadores de mayor cotización.
ggplot(train_data, aes(x = Gls, y = precio)) +
geom_point() +
geom_smooth(method = "lm", formula = y ~ x, color="darkviolet", se = FALSE) +
geom_line(data = pred_modelo_lmrob_goles, aes(x = Gls, y = precio_pred), color = "yellow") +
theme_bw()
modelos_simples <- list(simple_1 = modelo_clasico_goles,
simple_2 = modelo_lmrob_goles)
lista_predicciones_testing = map(.x = modelos_simples, .f = augment, newdata = test_data)
goles_clasico_test = lista_predicciones_testing$simple_1 %>%
metrics(truth=precio, estimate=.fitted) %>%
mutate(.estimate=round(.estimate, 4))
goles_robusto_test = lista_predicciones_testing$simple_2 %>%
metrics(truth=precio, estimate=.fitted) %>%
mutate(.estimate=round(.estimate, 4))
metrica_goles <- rbind(goles_clasico_test[c(1,3),], goles_robusto_test[c(1,3),])
modelitos_simples <- c(rep("Clasico - Goles",2),rep("Robusto - Goles",2))
metricas <- cbind(modelitos_simples, metrica_goles)
kable(metricas)
| modelitos_simples | .metric | .estimator | .estimate |
|---|---|---|---|
| Clasico - Goles | rmse | standard | 17503869 |
| Clasico - Goles | mae | standard | 9732598 |
| Robusto - Goles | rmse | standard | 19142968 |
| Robusto - Goles | mae | standard | 8713804 |
\(Precio\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)
modelo_multiple_lmrob <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data)
summary(modelo_multiple_lmrob)
##
## Call:
## lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast + continente + current_club_domestic_competition_id,
## data = train_data)
## \--> method = "MM"
## Residuals:
## Min 1Q Median 3Q Max
## -38166107 -1948976 313839 5696751 174801160
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -13710204 3541492 -3.871 0.000114
## Gls 526022 90783 5.794 8.86e-09
## Age 1499374 264013 5.679 1.71e-08
## I(Age^2) -31880 4959 -6.429 1.89e-10
## Ast 833746 130969 6.366 2.80e-10
## continenteamerica 600051 661817 0.907 0.364771
## continenteasia_oceania 32964436 5364894 6.144 1.11e-09
## continenteeuropa -373158 466154 -0.801 0.423585
## current_club_domestic_competition_idFR1 -491839 341530 -1.440 0.150112
## current_club_domestic_competition_idGB1 3289984 932242 3.529 0.000434
## current_club_domestic_competition_idIT1 -55126 348407 -0.158 0.874309
## current_club_domestic_competition_idL1 -478953 324300 -1.477 0.139983
##
## (Intercept) ***
## Gls ***
## Age ***
## I(Age^2) ***
## Ast ***
## continenteamerica
## continenteasia_oceania ***
## continenteeuropa
## current_club_domestic_competition_idFR1
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1
## current_club_domestic_competition_idL1
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Robust residual standard error: 3425000
## Multiple R-squared: 0.4751, Adjusted R-squared: 0.4701
## Convergence in 24 IRWLS iterations
##
## Robustness weights:
## 149 observations c(3,19,23,52,58,67,76,80,83,89,92,112,130,132,143,156,161,163,164,167,172,173,190,200,204,212,216,218,221,226,248,253,256,262,265,271,283,287,288,289,290,292,301,309,310,316,319,321,322,327,333,338,339,341,354,366,367,368,372,374,384,385,388,390,403,407,433,461,463,476,482,489,500,501,510,526,537,543,563,564,565,574,575,578,586,590,593,597,608,630,634,640,644,662,666,674,691,696,705,713,736,746,753,754,760,774,793,799,800,801,811,813,823,833,853,867,870,871,875,901,913,917,918,929,934,953,954,956,962,963,965,968,973,975,982,1019,1024,1036,1054,1063,1070,1091,1096,1123,1124,1130,1134,1138,1154)
## are outliers with |weight| = 0 ( < 8.6e-05);
## 72 weights are ~= 1. The remaining 936 ones are summarized as
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0002669 0.8555000 0.9522000 0.8486000 0.9836000 0.9990000
## Algorithmic parameters:
## tuning.chi bb tuning.psi refine.tol
## 1.548e+00 5.000e-01 4.685e+00 1.000e-07
## rel.tol scale.tol solve.tol zero.tol
## 1.000e-07 1.000e-10 1.000e-07 1.000e-10
## eps.outlier eps.x warn.limit.reject warn.limit.meanrw
## 8.643e-05 2.910e-09 5.000e-01 5.000e-01
## nResample max.it best.r.s k.fast.s k.max
## 500 50 2 1 200
## maxit.scale trace.lev mts compute.rd fast.s.large.n
## 200 0 1000 0 2000
## psi subsampling cov
## "bisquare" "nonsingular" ".vcov.avar1"
## compute.outlier.stats
## "SM"
## seed : int(0)
modelos_comparacion <- list(multiple_1 = modelo_clasico_multiple_1,
robusto_1 = modelo_multiple_lmrob)
lista_predicciones_testing = map(.x = modelos_comparacion, .f = augment, newdata = test_data)
metricas_clasico_test = lista_predicciones_testing$multiple_1 %>%
metrics(truth=precio, estimate=.fitted) %>%
mutate(.estimate=round(.estimate, 4))
metricas_robusto_test = lista_predicciones_testing$robusto_1 %>%
metrics(truth=precio, estimate=.fitted) %>%
mutate(.estimate=round(.estimate, 4))
metrica <- rbind(metricas_clasico_test[c(1,3),], metricas_robusto_test[c(1,3),])
modelitos_comparacion <- c(rep("Multiple - Precio",2),
rep("Robusto - Precio - psi = bisquare",2))
metricas <- cbind(modelitos_comparacion, metrica)
kable(metricas)
| modelitos_comparacion | .metric | .estimator | .estimate |
|---|---|---|---|
| Multiple - Precio | rmse | standard | 15450180 |
| Multiple - Precio | mae | standard | 8469906 |
| Robusto - Precio - psi = bisquare | rmse | standard | 18164916 |
| Robusto - Precio - psi = bisquare | mae | standard | 7909289 |
\(log(Precio)\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)
modelo_multiple_lmrob_2 <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data)
summary(modelo_multiple_lmrob_2)
##
## Call:
## lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + continente + current_club_domestic_competition_id,
## data = train_data)
## \--> method = "MM"
## Residuals:
## Min 1Q Median 3Q Max
## -4.15651 -0.71534 0.01675 0.68707 3.45838
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.796426 1.235981 4.690 3.06e-06
## Gls 0.111085 0.010745 10.339 < 2e-16
## Age 0.772800 0.090728 8.518 < 2e-16
## I(Age^2) -0.016112 0.001655 -9.734 < 2e-16
## Ast 0.170219 0.014713 11.569 < 2e-16
## continenteamerica 0.439570 0.130353 3.372 0.000771
## continenteasia_oceania 0.065008 0.310255 0.210 0.834070
## continenteeuropa 0.089042 0.106069 0.839 0.401378
## current_club_domestic_competition_idFR1 -0.231087 0.106080 -2.178 0.029578
## current_club_domestic_competition_idGB1 0.917136 0.110887 8.271 3.66e-16
## current_club_domestic_competition_idIT1 -0.014964 0.101669 -0.147 0.883015
## current_club_domestic_competition_idL1 -0.282461 0.098817 -2.858 0.004335
##
## (Intercept) ***
## Gls ***
## Age ***
## I(Age^2) ***
## Ast ***
## continenteamerica ***
## continenteasia_oceania
## continenteeuropa
## current_club_domestic_competition_idFR1 *
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1
## current_club_domestic_competition_idL1 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Robust residual standard error: 1.024
## Multiple R-squared: 0.4842, Adjusted R-squared: 0.4793
## Convergence in 17 IRWLS iterations
##
## Robustness weights:
## 101 weights are ~= 1. The remaining 1056 ones are summarized as
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.06249 0.86890 0.94640 0.90070 0.98330 0.99900
## Algorithmic parameters:
## tuning.chi bb tuning.psi refine.tol
## 1.548e+00 5.000e-01 4.685e+00 1.000e-07
## rel.tol scale.tol solve.tol zero.tol
## 1.000e-07 1.000e-10 1.000e-07 1.000e-10
## eps.outlier eps.x warn.limit.reject warn.limit.meanrw
## 8.643e-05 2.910e-09 5.000e-01 5.000e-01
## nResample max.it best.r.s k.fast.s k.max
## 500 50 2 1 200
## maxit.scale trace.lev mts compute.rd fast.s.large.n
## 200 0 1000 0 2000
## psi subsampling cov
## "bisquare" "nonsingular" ".vcov.avar1"
## compute.outlier.stats
## "SM"
## seed : int(0)
pred_modelo_robusto_multiple <- augment(modelo_multiple_lmrob_2, newdata = train_data)
pred_modelo_robusto_multiple$exp_fitted <- exp(pred_modelo_robusto_multiple$.fitted)
metricas2 = metrics(data = pred_modelo_robusto_multiple,
truth = precio, estimate = exp_fitted) %>%
mutate(.estimate = round(.estimate, 4))
#rcuadrado <- metricas1$.estimate[2]
#cat("R-cuadrado = ", rcuadrado)
#metricas1
# Calcular el R² ajustado manualmente
n_rob <- nrow(pred_modelo_robusto_multiple) # Número de observaciones
p_rob <- length(coef(modelo_multiple_lmrob_2)) - 1 # Número de predictores (restamos 1 por el intercepto)
r2_rob <- metricas2 %>% filter(.metric == "rsq") %>% pull(.estimate)
r2_ajustado_rob <- 1 - ((1 - r2_rob) * (n_rob - 1) / (n_rob - p_rob - 1))
# Mostrar el R² ajustado
cat("R^2 ajustado = ", r2_ajustado_rob)
## R^2 ajustado = 0.3002414
modelos_comparacion <- list(multiple_2 = modelo_clasico_multiple,
robusto_2 = modelo_multiple_lmrob_2)
lista_predicciones_testing = map(.x = modelos_comparacion, .f = augment, newdata = test_data)
metricas2_test = lista_predicciones_testing$multiple_2 %>%
mutate(exp_fitted= exp(.fitted)) %>%
metrics(truth=precio, estimate=exp_fitted) %>%
mutate(.estimate=round(.estimate, 4))
metricas3_test = lista_predicciones_testing$robusto_2 %>%
mutate(exp_fitted= exp(.fitted)) %>%
metrics(truth=precio, estimate=exp_fitted) %>%
mutate(.estimate=round(.estimate, 4))
metrica <- rbind(metricas2_test[c(1,3),], metricas3_test[c(1,3),])
modelitos_comparacion <- c(rep("Multiple - log(Precio)",2),
rep("Robusto - log(Precio) - psi = bisquare",2))
metricas <- cbind(modelitos_comparacion, metrica)
kable(metricas)
| modelitos_comparacion | .metric | .estimator | .estimate |
|---|---|---|---|
| Multiple - log(Precio) | rmse | standard | 17508456 |
| Multiple - log(Precio) | mae | standard | 7357616 |
| Robusto - log(Precio) - psi = bisquare | rmse | standard | 17592430 |
| Robusto - log(Precio) - psi = bisquare | mae | standard | 7302473 |
Se aplica la misma fórmula que el modelo anterior pero en lugar de usar la función \(\psi\) por defecto bisqueare hacemos 5 modelos nuevos usando en cada uno diferentes \(\rho\): lqq, welsh, optimal, hampel y ggw.
modelo_multiple_lmrob_lqq <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data,
psi = "lqq")
modelo_multiple_lmrob_lqq_2 <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data,
psi = "lqq")
modelo_multiple_lmrob_welsh <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data,
psi = "welsh")
modelo_multiple_lmrob_welsh_2 <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data,
psi = "welsh")
modelo_multiple_lmrob_optimal <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data,
psi = "optimal")
modelo_multiple_lmrob_optimal_2 <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast +
continente + current_club_domestic_competition_id,
data=train_data,
psi = "optimal")
# Agrupar todos los modelos
modelos <- list(
multiple_1 = modelo_clasico_multiple_1,
multiple_2 = modelo_clasico_multiple,
robusto_1 = modelo_multiple_lmrob,
robusto_2 = modelo_multiple_lmrob_2,
robusto_3_1 = modelo_multiple_lmrob_lqq_2,
robusto_3 = modelo_multiple_lmrob_lqq,
robusto_4_1 = modelo_multiple_lmrob_welsh_2,
robusto_4 = modelo_multiple_lmrob_welsh,
robusto_5_1 = modelo_multiple_lmrob_optimal_2,
robusto_5 = modelo_multiple_lmrob_optimal
)
# Definir nombres de modelos
modelitos <- c(rep("Clasico - Precio",3),
rep("Clasico - log(Precio)",3),
rep("Robusto - Precio",3),
rep("Robusto - log(Precio) - psi = bisquare",3),
rep("Robusto - Precio - psi = lqq",3),
rep("Robusto - log(Precio) - psi = lqq",3),
rep("Robusto - Precio - psi = welsh",3),
rep("Robusto - log(Precio) - psi = welsh",3),
rep("Robusto - Precio - psi = optimal",3),
rep("Robusto - log(Precio) - psi = optimal",3))
# Calcular métricas para entrenamiento y prueba
calcular_metricas <- function(modelo, datos, tipo) {
pred <- augment(modelo, newdata = datos)
if("log" %in% names(modelo$call)) {
pred$pred_final <- exp(pred$.fitted)
} else {
pred$pred_final <- pred$.fitted
}
metrics(data = pred, truth = precio, estimate = pred_final) %>%
mutate(.estimate = round(.estimate, 4),
tipo_datos = tipo)
}
# Calcular métricas
metricas_entrenamiento <- map_dfr(modelos, ~calcular_metricas(., train_data, "Entrenamiento"), .id = "modelo")
metricas_prueba <- map_dfr(modelos, ~calcular_metricas(., test_data, "Prueba"), .id = "modelo")
# Crear dataframe de métricas
df_metricas <- data.frame(
modelo = rep(modelitos, 2),
tipo_datos = c(metricas_entrenamiento$tipo_datos, metricas_prueba$tipo_datos),
metrica = c(metricas_entrenamiento$.metric, metricas_prueba$.metric),
valor = c(metricas_entrenamiento$.estimate, metricas_prueba$.estimate)
) %>%
distinct() %>%
filter(metrica %in% c("rmse", "mae", "rsq"))
# Gráfico RMSE
ggplot(df_metricas %>% filter(metrica == "rmse"),
aes(x = valor, y = modelo, fill = tipo_datos)) +
geom_col(position = "dodge") +
geom_text(aes(label = scales::comma(valor)),
position = position_dodge(width = 0.9),
hjust = 1,
color = "black",
size = 3) +
labs(title = "Comparación de RMSE por Modelo",
x = "RMSE",
y = "Modelo",
fill = "Conjunto de datos") +
scale_fill_manual(values = c("Entrenamiento" = "#99CCFF", "Prueba" = "#003366"))
# Gráfico MAE
ggplot(df_metricas %>% filter(metrica == "mae"),
aes(x = valor, y = modelo, fill = tipo_datos)) +
geom_col(position = "dodge") +
geom_text(aes(label = scales::comma(valor)),
position = position_dodge(width = 0.9),
hjust = 1,
color = "black",
size = 3) +
labs(title = "Comparación de MAE por Modelo",
x = "MAE",
y = "Modelo",
fill = "Conjunto de datos") +
scale_fill_manual(values = c("Entrenamiento" = "#99FF99", "Prueba" = "#006600"))
# Gráfico R²
ggplot(df_metricas %>% filter(metrica == "rsq"),
aes(x = valor, y = modelo, fill = tipo_datos)) +
geom_col(position = "dodge") +
geom_text(aes(label = scales::percent(valor)),
position = position_dodge(width = 0.9),
hjust = 1,
color = "black",
size = 3) +
labs(title = "Comparación de R² por Modelo",
x = "R² (porcentaje)",
y = "Modelo",
fill = "Conjunto de datos") +
scale_fill_manual(values = c("Entrenamiento" = "#FFB6C1", "Prueba" = "#8B0000"))
El análisis estadístico revela patrones fundamentales en la valoración de jugadores que desafían varias percepciones tradicionales del mercado.
La evidencia empírica demuestra una clara segmentación del mercado europeo, con ineficiencias significativas que crean oportunidades estratégicas.
La elección metodológica de utilizar regresión robusta con transformación logarítmica demostró ser crucial para la validez del análisis.
El método MM-estimation implementado en Robustbase, que utiliza por defecto la función bisquare, permitió manejar eficazmente la heterogeneidad inherente al mercado de fichajes, donde las valoraciones extremas son comunes pero no necesariamente outliers estadísticos.
La transformación logarítmica no solo mejoró las propiedades estadísticas del modelo, sino que también proporcionó una interpretación más intuitiva en términos de variaciones porcentuales, alineándose naturalmente con la forma en que el mercado evalúa los cambios en el valor de los jugadores.
El uso de estimadores robustos reveló que el mercado de fichajes, aunque volátil, mantiene una estructura subyacente que puede ser modelada de manera más precisa cuando se utilizan métodos que equilibran robustez y eficiencia estadística.
El modelo robusto, con un R² ajustado de 30%, captura las dinámicas fundamentales del mercado mientras filtra el “ruido” especulativo.
La efectividad de la función bisquare sugiere que, contrario a la percepción popular, las valoraciones extremas en el mercado siguen patrones identificables y no son puramente especulativas.
La Premier League mantiene una prima de valoración del 150.2% sobre La Liga, un diferencial que excede significativamente las diferencias en ingresos operativos entre estas ligas.
Esta sobrevaloración sistemática sugiere una burbuja estructural en el mercado inglés, particularmente notable en comparación con Bundesliga (-24.6%) y Ligue 1 (-20.6%), donde el talento parece estar sistemáticamente infravalorado.
Una observación particularmente relevante es la mayor valoración de las asistencias (+18.5%) sobre los goles (+11.7%). Esta diferencia refleja una evolución en la comprensión del valor creativo en el fútbol moderno, donde la capacidad de generar oportunidades se premia por encima de la finalización. Este patrón sugiere una sofisticación creciente en la evaluación del talento.
La relación cuadrática con la edad emerge como un factor crítico en la valoración, señalando una ventana óptima de valoración que el mercado reconoce consistentemente. Este patrón tiene implicaciones profundas para la gestión de activos deportivos y la planificación de plantillas a largo plazo.
La brecha de valoración del 55.2% entre jugadores americanos y africanos, controlando por rendimiento y liga, revela un sesgo de mercado significativo. Esta disparidad, estadísticamente significativa (p-value = 0.0008), indica una ineficiencia de mercado estructural que trasciende el rendimiento deportivo puro.
Las ineficiencias identificadas en el mercado sugieren que el valor real de un jugador puede diferir significativamente de las valoraciones de mercado actuales, especialmente en ligas secundarias y mercados emergentes. La transformación logarítmica del modelo revela que estas discrepancias siguen patrones predecibles y explotables.
El análisis también señala una evolución en la estructura del mercado, donde los factores tradicionales de valoración están siendo complementados por métricas más sofisticadas. La significativa prima por creatividad sugiere un mercado que está comenzando a valorar más acertadamente las contribuciones tácticas complejas.
Estos hallazgos indican que el mercado de transferencias, aunque cada vez más sofisticado, mantiene ineficiencias estructurales significativas. La combinación de sesgos geográficos, primas de liga y valoración de habilidades específicas crea un panorama complejo pero analíticamente navegable para la identificación de valor.